home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / bignum-test.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  3.2 KB  |  105 lines
  1. ;;;; -*- Package: Bignum -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: bignum-test.lisp,v 1.3 91/05/24 19:35:48 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    Some stuff to check that bignum operations are retuning the correct
  15. ;;; results.
  16. ;;; 
  17. (in-package "BIGNUM")
  18.  
  19. (defvar *in-bignum-wrapper* nil)
  20.  
  21. (defmacro def-bignum-wrapper (name lambda-list &body body)
  22.   (let ((var-name (ext:symbolicate "*OLD-" name "*"))
  23.     (wrap-name (ext:symbolicate "WRAP-" name))
  24.     (args (mapcar #'(lambda (x)
  25.               (if (listp x) (car x) x))
  26.               (remove-if #'(lambda (x)
  27.                      (member x lambda-list-keywords))
  28.                  lambda-list))))
  29.     `(progn
  30.        (defvar ,var-name (fdefinition ',name))
  31.        (defun ,wrap-name ,lambda-list
  32.      (if *in-bignum-wrapper*
  33.          (funcall ,var-name ,@args)
  34.          (let ((*in-bignum-wrapper* t))
  35.            ,@body)))
  36.        (setf (fdefinition ',name) #',wrap-name))))
  37.  
  38. (defun big= (x y)
  39.   (= (if (typep x 'bignum)
  40.      (%normalize-bignum x (%bignum-length x))
  41.      x)
  42.      (if (typep y 'bignum)
  43.      (%normalize-bignum y (%bignum-length y))
  44.      y)))
  45.  
  46. (def-bignum-wrapper add-bignums (x y)
  47.   (let ((res (funcall *old-add-bignums* x y)))
  48.     (assert (big= (- res y) x))
  49.     res))
  50.  
  51. (def-bignum-wrapper multiply-bignums (x y)
  52.   (let ((res (funcall *old-multiply-bignums* x y)))
  53.     (if (zerop x)
  54.     (assert (zerop res))
  55.     (multiple-value-bind (q r) (truncate res x)
  56.       (assert (and (zerop r) (big= q y)))))
  57.     res))
  58.  
  59. (def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
  60.   (let ((res (funcall *old-negate-bignum* x fully-normalized)))
  61.     (assert (big= (- res) x))
  62.     res))
  63.  
  64. (def-bignum-wrapper subtract-bignum (x y)
  65.   (let ((res (funcall *old-subtract-bignum* x y)))
  66.     (assert (big= (+ res y) x))
  67.     res))
  68.  
  69. (def-bignum-wrapper multiply-bignum-and-fixnum (x y)
  70.   (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
  71.     (if (zerop x)
  72.     (assert (zerop res))
  73.     (multiple-value-bind (q r) (truncate res x)
  74.       (assert (and (zerop r) (big= q y)))))
  75.     res))
  76.  
  77. (def-bignum-wrapper multiply-fixnums (x y)
  78.   (let ((res (funcall *old-multiply-fixnums* x y)))
  79.     (if (zerop x)
  80.     (assert (zerop res))
  81.     (multiple-value-bind (q r) (truncate res x)
  82.       (assert (and (zerop r) (big= q y)))))
  83.     res))
  84.  
  85. (def-bignum-wrapper bignum-ashift-right (x shift)
  86.   (let ((res (funcall *old-bignum-ashift-right* x shift)))
  87.     (assert (big= (ash res shift) (logand x (ash -1 shift))))
  88.     res))
  89.  
  90. (def-bignum-wrapper bignum-ashift-left (x shift)
  91.   (let ((res (funcall *old-bignum-ashift-left* x shift)))
  92.     (assert (big= (ash res (- shift)) x))
  93.     res))
  94.  
  95. (def-bignum-wrapper bignum-truncate (x y)
  96.   (multiple-value-bind (q r)
  97.                (funcall *old-bignum-truncate* x y)
  98.     (assert (big= (+ (* q y) r) x))
  99.     (values q r)))
  100.  
  101. (def-bignum-wrapper bignum-compare (x y)
  102.   (let ((res (funcall *old-bignum-compare* x y)))
  103.     (assert (big= (signum (- x y)) res))
  104.     res))
  105.